perm filename TREST.OLD[MSS,LCS]2 blob
sn#105213 filedate 1974-06-01 generic text, type T, neo UTF8
00100 C******* SUBRS TAIL, FERMTA, REST, RDDATA, BREP, EXCH, SORT2, ALPHA
00200 SUBROUTINE TAIL(RJX,RA,RMINI)
00300 COMMON /STF/RSTFAC(8),RSTJC
00400 COMMON /PLTR/IPLT,RHT,DIS
00500 DIMENSION ITAIL(16)
00800 DATA ITAIL/16,100090007,110012,120016,200120016,120019,100026,
00850 1 80030,20036, 40, 33, 30031, 50029,80025,100022,120016/
01100 Q=-1.
01200 IF(RA)Q=1.
01300 CALL CENTER(RJY)
01400 CALL JDRAW(ITAIL(1),RJX,RJY,RMINI,1.,Q)
01500 1 IF(IPLT.GE.0)RETURN
01600 IF(RMINI.NE.RSTJC)Q=Q*.6
01700 CC CALL OLDFIL(ITAIL(10),RJX,RJY,ABS(Q),Q)
01750 CALL FILLMS(ITAIL(1),ITAIL(5),RJX,RJY,ABS(Q),Q)
01900 C RA=-,STEM UP; RA=+, STEM DOWN.
02000 END
02100
02200 SUBROUTINE REST
02300 COMMON /STF/RSTFAC(8),RSTJC
02400 COMMON /PLTR/IPLT,RHT,DIS
02500 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
02600 EQUIVALENCE(JE,JQ(3))
02700 DIMENSION LRST(4),IRST(74)
02800
02900 IF(LRST(1).EQ.0)CALL RDDATA('REST',LRST,IRST)
03000 L=JE
03100 IF(L.GT.1)L=1
03200 K=LRST(L+3)
03300 C L>3 WHEN SEVERAL TAILS ON REST
03400 CALL CENTER(CENTR)
03500 CALL JDRAW(IRST(K),RJB,CENTR,RSTJC,1.,1.)
03600 IF(JE.OR.IPLT.GE.0)RETURN
03700 CALL OLDFIL(IRST(IRST(K)+K+1),RJB,CENTR,1.,1.)
03800 C WHY GO THROUGH NOTWRT??
03900 END
04000
04100 SUBROUTINE RDDATA(NM,JARY,IARY)
04200 C READS DATA
04300 DIMENSION JARY(1),IARY(1)
04400 REWIND 23
04500 CALL IFILE(23,NM)
04600 READ(23,5)K,(JARY(K),K=1,10)
04700 N=1
04800 1 READ(23,5,END=2)K,L,(IARY(K),K=N,N+L-1)
04900 N=N+L
05000 GO TO 1
05100 2 RETURN
05200 5 FORMAT(12I)
05300 END
05400
05500 C FOR SINGLE (OR DOUBLE) BAR REPEAT SIGN
05600 SUBROUTINE BREP(RJB,RSTJC)
05700 DIMENSION JREP(1),IREP(35)
05800 DATA IREP/35,100000015,280043,290043, 10015, 20015, 300043,310043
05900 1,30015, 40015, 320043,100020037, 30038, 40038, 50037
06000 1,50036, 40035, 30035, 20036, 20037, 50037, 20036, 40036
06100 1,100270022,280021,290021,300022,300023,290024,280024,270023
06200 1,270022, 300022, 270023, 290023/
06300 CC IF(JREP(1).EQ.0)CALL RDDATA('BREP',JREP,IREP)
06400 CALL CENTER(R)
06500 CALL JDRAW(IREP,RJB,R,RSTJC,1.,1.)
06600 END
06700
06800 SUBROUTINE FERMTA(RINV)
06900 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
07000 COMMON /PLTR/IPLT,RHT,DIS
07100 COMMON /STF/RSTFAC(8),RSTJC
07200 DIMENSION JFERM(24)
07210 DATA JFERM/24,310020003,10010010,20015,60017,110017,160015,
07225 1 190010,200003,170010,150012,120014,70014,30012,10010,
07247 1 10020003,100070007,80008,100008,110007,110006,100005,80005
07273 1 ,70006/
07373 CC IF(JFERM(1).EQ.0)CALL RDDATA('FERM',JFERM,IFERM)
07400 CC R=INV
07500 CALL JDRAW(JFERM,RJB,CENTR,RSTJC,1.,RINV)
07600 CC IF(IPLT)CALL OLDFIL(IFERM(IFERM(1)+2),RJB,CENTR,1.,RINV)
07610 IF(IPLT)CALL FILLMS(JFERM(1),JFERM(2),RJB,CENTR,1.,RINV)
07700 END
07800
07900 SUBROUTINE EXCH(X,Y)
08000 Z=X
08100 X=Y
08200 Y=Z
08300 END
08400 SUBROUTINE SORT2(RPOS,M)
08500 DIMENSION RPOS(2,200)
08600 L=2
08700 3 J=-1
08800 RX=RPOS(1,L-1)
08900 DO 2 K=L,M
09000 IF(RPOS(1,K).GE.RX)GO TO 2
09100 RX=RPOS(1,K)
09200 C WHY WERE ALL THE RX'S JX ????? 9/6/73
09300 J=K
09400 2 CONTINUE
09500 IF(J)GO TO 4
09600 K=L-1
09700 CALL EXCH(RPOS(1,K),RPOS(1,J))
09800 CALL EXCH(RPOS(2,K),RPOS(2,J))
09900 4 L=L+1
10000 IF(L.LE.M)GO TO 3
10100 END
10500 C****** FOR LISTS OF LETTERS, ETC. *******
10600 SUBROUTINE ALPHA
10610 COMMON /PLTR/IPLT,RHT,DIS
10700 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
10800 EQUIVALENCE(JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3)),
10900 1(RJH,RJQ(6)),(NRJ,RJQ(8)),
11000 1(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
11100 1,(JK,JQ(9)),(JF,JQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
11200 COMMON/STF/RSTFAC(8),RSTJC
11300 DATA RS/1.1/,R4/-2.1/,RSPC/.9/,JFIX/-1/
11400
11500 IF(JA.EQ.20)GO TO 20
11600 CC IFNT=0
11700 C PRIMITIVE IS DEFAULT FONT. #=SET BACK TO PRIM.
11800 C ONLY 11 LETTERS WITHOUT FONT RESET.
11900 CC JA=5
12000 54 R=19.7*RJE*RSTJC
12100 RB=JB
12200 CC J=R
12300 CC RND=R-J
12400 CC R=0
12410 CC RSX=RS
12500 DO 50 KA=4,6
12600 JY=RJQ(KA)*100.+.2
12700 JX=1000000
12800 DO 53 LA=1,4
12900 JF=JY/JX
13000 IF(JF.EQ.47.OR.JF.GT.90)GO TO 2
13100 IF(JF.LT.47.AND.IFNT.EQ.0)GO TO 3
13200 C JUMP TO USE PRIMITIVE ALPHABET.
13205 CC RS=RSX
13210 IF((JF.GT.9.AND.JF.LT.36).OR.JF.GT.47)GO TO 10
13220 C NEXT FOR NUMBERS, SPACE AND PUNCTUATION.
13230 CC RSX=RS
13240 RSX=RSPC
13245 IF(JF.GT.9)GO TO 3
13250 GO TO 4
13300 10 IF(JF.LT.47)GO TO 5
13400 IF(JF.NE.48)GO TO 7
13500 IFNT=1
13600 C $=48=UPPER CASE
13700 CC RSX=1.1
13800 GO TO 11
13900 7 IF(JF.NE.49)GO TO 8
14000 IFNT=-1
14100 C %=LOWER CASE
14200 CC RSX=.73
14300 GO TO 11
14400 8 IF(JF.NE.50)GO TO 13
14410 NR='BDR40'
14420 CC IF(JFIX)NR='FIX40'
14500 C &=NON-ITALICS -- JFIX IS TEMPORARY SWITCH 5/74
14600 13 IF(JF.NE.51)GO TO 14
14610 NR='BDI40'
14620 CC IF(JFIX)NR='FIZ40'
14700 C @=51=ITALICS
14800 14 IF(JF.NE.52)GO TO 11
14900 IFNT=0
14910 C #=52=PRIMITIVE
15000 JA=5
15100 RSX=1.
15200 GO TO 11
15210 9 IF(JF.LT.52)GO TO 11
15220 IF(JF.EQ.53)FILL=-2
15230 IF(JF.EQ.54)FILL=0
15240 C < = 53 = NO FILL, > = 54 = FILL
15250 GO TO 11
15260 5 IF(IFNT)RSX=.8
15270 IF(JF.LE.9)RSX=RSPC
15300 IF(JF.EQ.22.OR.JF.EQ.32)RSX=RSX*1.1
15310 IF(JF.EQ.1.OR.JF.EQ.18.OR.JF.EQ.19.OR.(JF.EQ.21.AND.IFNT))
15355 1 RSX=RSX*.8
15370 4 IF(JFIX.AND.IPLT.GE.0)GO TO 3
15380 C JFIX=-1 FOR FIXED WIDTH OF FONTS. = AND ONLY DPYS PRIMITIVE.
15390 C******** SET JFIX TO -1 IN DDT TO USE FIXED WIDTH.
15400 JE=JF
15500 IF(IFNT.AND.JE.GT.9)JE=JE+26
15600 RX=RJF
15700 RJF=RJE*.28
15800 C .29 IS SIZE FACTOR -- PERHAPS CHANGE SIZE IN FONT TO =1.
15900 RY=RJG
16000 RJG=RJF
16100 RZ=RJH
16110 RW=RJD
16155 RJD=RJD+R4
16200 RJH=FILL
16210 NRJ=NR
16255 C GETS RIGHT FILE
16300 JA=11
16400 CALL NOTWRT
16500 RJF=RX
16600 RJG=RY
16700 RJH=RZ
16750 RJD=RW
16800 C PUTS BACK RIGHT STUFF
16810 IF(JFIX)GO TO 12
16900 GO TO 2
17000
17100 3 JA=5
17200 CALL NOTWRT
17300 C 47=BLANK (WAS 99)
17400 CC2 JB=JB+J
17410 12 RSX=1.
17500 2 RB=RB+R*RSX
17600 JB=ROFF(RB)
17700 CC R=R+RND
17800 CC IF(R.LT.1.0)GO TO 11
17900 CC JB=JB+1
18000 CC R=R-1.0
18100 11 JY=JY-JF*JX
18110 RSX=RS
18200 53 JX=JX/100
18300 50 CONTINUE
18400 RETURN
18500
18600 C FOR TRILLS
18700 20 R=RJB
18800 C R SAVES RJB(WHICH GETS CLOBBERED WHEN 'TR' IS WRITTEN.)
18900 C 20, POS1, STF, NT#, 0, POS2, X IF X=1 THEN NO WAVEY LINE
19000 RJE=.65
19100 JE=0
19200 JA=5
19300 JF=29
19400 C DRAWS T
19500 CALL NOTWRT
19600 JF=27
19700 C DRAWS R
19800 JB=JB+11*RSTJC
19900 51 CALL NOTWRT
20000 IF(JG.NE.0)RETURN
20100 JB=JB+16*RSTJC
20200 C RETURN IF NO WAVY LINE IS NEEDED
20300 JA=4
20400 RJB=R+4.*RSTJC
20500 JG=-2
20600 C JG IS SWITCH TO DRAW WIGGLE
20700 RJE=RJD+.8
20800 CALL ITMSUB
20900 END